home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / pcl-rev4.lha / defclass.lisp < prev    next >
Lisp/Scheme  |  1990-09-12  |  10KB  |  290 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. ;;;
  31. ;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'.
  32. ;;;
  33. ;;; The original motiviation for this function was to deal with the bug in
  34. ;;; the Genera compiler that prevents lambda expressions in top-level forms
  35. ;;; other than DEFUN from being compiled.
  36. ;;;
  37. ;;; Now this function is used to grab other functionality as well.  This
  38. ;;; includes:
  39. ;;;   - Preventing the grouping of top-level forms.  For example, a
  40. ;;;     DEFCLASS followed by a DEFMETHOD may not want to be grouped
  41. ;;;     into the same top-level form.
  42. ;;;   - Telling the programming environment what the pretty version
  43. ;;;     of the name of this form is.  This is used by WARN.
  44. ;;; 
  45. (defun make-top-level-form (name times form)
  46.   (flet ((definition-name ()
  47.        (if (and (listp name)
  48.             (memq (car name) '(defmethod defclass class method method-combination)))
  49.            (format nil "~A~{ ~S~}"
  50.                (capitalize-words (car name) ()) (cdr name))
  51.            (format nil "~S" name))))
  52.     (definition-name)
  53.     #+Genera
  54.     (progn
  55.       #-Genera-Release-8
  56.       (let ((thunk-name (gensym "TOP-LEVEL-FORM")))
  57.     `(eval-when ,times
  58.        (defun ,thunk-name ()
  59.          (declare (sys:function-parent
  60.             ,(cond ((listp name)
  61.                 (case (first name)
  62.                   (defmethod `(method ,@(rest name)))
  63.                   (otherwise (second name))))
  64.                    (t name))
  65.             ,(cond ((listp name)
  66.                 (case (first name)
  67.                   ((defmethod defgeneric) 'defun)
  68.                   ((defclass) 'defclass)
  69.                   (otherwise (first name))))
  70.                    (t 'defun))))
  71.          ,form)
  72.        (,thunk-name)))
  73.       #+Genera-Release-8
  74.       `(compiler-let ((compiler:default-warning-function ',name))
  75.      (eval-when ,times
  76.        (funcall #'(lambda ()
  77.             (declare ,(cond ((listp name)
  78.                      (case (first name)
  79.                        ((defclass)
  80.                         `(sys:function-parent ,(second name) defclass))
  81.                        ((defmethod)
  82.                         `(sys:function-name (method ,@(rest name))))
  83.                        ((defgeneric)
  84.                         `(sys:function-name ,(second name)))
  85.                        (otherwise
  86.                          `(sys:function-name ,name))))
  87.                     (t
  88.                      `(sys:function-name ,name))))
  89.             ,form)))))
  90.     #+LCL3.0
  91.     `(compiler-let ((lucid::*compiler-message-string*
  92.               (or lucid::*compiler-message-string*
  93.               ,(definition-name))))
  94.        (eval-when ,times ,form))
  95.     #-(or Genera LCL3.0)
  96.     (make-progn `',name `(eval-when ,times ,form))))
  97.  
  98. (defun make-progn (&rest forms)
  99.   (let ((progn-form nil))
  100.     (labels ((collect-forms (forms)
  101.            (unless (null forms)
  102.          (collect-forms (cdr forms))
  103.          (if (and (listp (car forms))
  104.               (eq (caar forms) 'progn))
  105.              (collect-forms (cdar forms))
  106.              (push (car forms) progn-form)))))
  107.       (collect-forms forms)
  108.       (cons 'progn progn-form))))
  109.  
  110.  
  111.  
  112. ;;; 
  113. ;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is fixed.
  114. ;;; DEFCLASS always expands into a call to LOAD-DEFCLASS.  Until the meta-
  115. ;;; braid is set up, LOAD-DEFCLASS has a special definition which simply
  116. ;;; collects all class definitions up, when the metabraid is initialized it
  117. ;;; is done from those class definitions.
  118. ;;;
  119. ;;; After the metabraid has been setup, and the protocol for defining classes
  120. ;;; has been defined, the real definition of LOAD-DEFCLASS is installed by the
  121. ;;; file defclass.lisp
  122. ;;; 
  123. (defmacro DEFCLASS (name direct-superclasses direct-slots &rest options)
  124.   (declare (indentation 2 4 3 1))
  125.   (expand-defclass name direct-superclasses direct-slots options))
  126.  
  127. (defun expand-defclass (name supers slots options)
  128.   (setq supers  (copy-tree supers)
  129.     slots   (copy-tree slots)
  130.     options (copy-tree options))
  131.   (let ((metaclass 'standard-class))
  132.     (dolist (option options)
  133.       (if (not (listp option))
  134.           (error "~S is not a legal defclass option." option)
  135.           (when (eq (car option) ':metaclass)
  136.             (unless (legal-class-name-p (cadr option))
  137.               (error "The value of the :metaclass option (~S) is not a~%~
  138.                       legal class name."
  139.                      (cadr option)))
  140.             (setq metaclass (cadr option))
  141.         (setf options (remove option options))
  142.         (return t))))
  143.  
  144.     (let ((*initfunctions* ())
  145.       (*accessors* ()))            ;Truly a crock, but we got
  146.                         ;to have it to live nicely.
  147.       (declare (special *initfunctions* *accessors*))
  148.       (let ((canonical-slots
  149.           (mapcar #'(lambda (spec)
  150.               (canonicalize-slot-specification name spec))
  151.               slots))
  152.         (other-initargs
  153.           (mapcar #'(lambda (option)
  154.               (canonicalize-defclass-option name option))
  155.               options)))
  156.     (do-standard-defsetfs-for-defclass *accessors*)
  157.     (make-top-level-form `(defclass ,name)
  158.                  *defclass-times*
  159.       `(let ,(mapcar #'cdr *initfunctions*)
  160.          (load-defclass ',name
  161.                 ',metaclass
  162.                 ',supers
  163.                 (list ,@canonical-slots)
  164.                 (list ,@(apply #'append other-initargs))
  165.                 ',*accessors*)))))))
  166.  
  167. (defun make-initfunction (initform)
  168.   (declare (special *initfunctions*))
  169.   (cond ((or (eq initform 't)
  170.          (equal initform ''t))
  171.      '(function true))
  172.     ((or (eq initform 'nil)
  173.          (equal initform ''nil))
  174.      '(function false))
  175.     ((or (eql initform '0)
  176.          (equal initform ''0))
  177.      '(function zero))
  178.     (t
  179.      (let ((entry (assoc initform *initfunctions* :test #'equal)))
  180.        (unless entry
  181.          (setq entry (list initform
  182.                    (gensym)
  183.                    `(function (lambda () ,initform))))
  184.          (push entry *initfunctions*))
  185.        (cadr entry)))))
  186.  
  187. (defun canonicalize-slot-specification (class-name spec)
  188.   (declare (special *accessors*))
  189.   (cond ((and (symbolp spec)
  190.           (not (keywordp spec))
  191.           (not (memq spec '(t nil))))           
  192.      `'(:name ,spec))
  193.     ((not (consp spec))
  194.      (error "~S is not a legal slot specification." spec))
  195.     ((null (cdr spec))
  196.      `'(:name ,(car spec)))
  197.     ((null (cddr spec))
  198.      (error "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~
  199.                  Convert it to ~S"
  200.         class-name spec (list (car spec) :initform (cadr spec))))
  201.     (t
  202.      (let* ((name (pop spec))
  203.         (readers ())
  204.         (writers ())
  205.         (initargs ())
  206.         (unsupplied (list nil))
  207.         (initform (getf spec :initform unsupplied)))
  208.        (doplist (key val) spec
  209.          (case key
  210.            (:accessor (push val *accessors*)
  211.               (push val readers)
  212.               (push `(setf ,val) writers))
  213.            (:reader   (push val readers))
  214.            (:writer   (push val writers))
  215.            (:initarg  (push val initargs))))
  216.        (loop (unless (remf spec :accessor) (return)))
  217.        (loop (unless (remf spec :reader)   (return)))
  218.        (loop (unless (remf spec :writer)   (return)))
  219.        (loop (unless (remf spec :initarg)  (return)))
  220.        (setq spec `(:name     ',name
  221.             :readers  ',readers
  222.             :writers  ',writers
  223.             :initargs ',initargs
  224.             ',spec))
  225.        (if (eq initform unsupplied)
  226.            `(list* ,@spec)
  227.            `(list* :initfunction ,(make-initfunction initform) ,@spec))))))
  228.                         
  229. (defun canonicalize-defclass-option (class-name option)  
  230.   (declare (ignore class-name))
  231.   (case (car option)
  232.     (:default-initargs
  233.       (let ((canonical ()))
  234.     (let (key val (tail (cdr option)))
  235.       (loop (when (null tail) (return nil))
  236.         (setq key (pop tail)
  237.               val (pop tail))
  238.         (push ``(,',key ,,(make-initfunction val) ,',val) canonical))
  239.       `(':direct-default-initargs (list ,@(nreverse canonical))))))
  240.     (otherwise
  241.       `(',(car option) ',(cdr option)))))
  242.  
  243.  
  244. ;;;
  245. ;;; This is the early definition of load-defclass.  It just collects up all
  246. ;;; the class definitions in a list.  Later, in the file braid1.lisp, these
  247. ;;; are actually defined.
  248. ;;;
  249.  
  250.  
  251. ;;;
  252. ;;; Each entry in *early-class-definitions* is an early-class-definition.
  253. ;;; 
  254. ;;;
  255. (defparameter *early-class-definitions* ())
  256.  
  257. (defun make-early-class-definition
  258.        (name source metaclass
  259.     superclass-names canonical-slots other-initargs)
  260.   (list 'early-class-definition
  261.     name source metaclass
  262.     superclass-names canonical-slots other-initargs))
  263.   
  264. (defun ecd-class-name        (ecd) (nth 1 ecd))
  265. (defun ecd-source            (ecd) (nth 2 ecd))
  266. (defun ecd-metaclass         (ecd) (nth 3 ecd))
  267. (defun ecd-superclass-names  (ecd) (nth 4 ecd))
  268. (defun ecd-canonical-slots   (ecd) (nth 5 ecd))
  269. (defun ecd-other-initargs    (ecd) (nth 6 ecd))
  270.  
  271. (proclaim '(notinline load-defclass))
  272. (defun load-defclass
  273.        (name metaclass supers canonical-slots canonical-options accessor-names)
  274.   (setq supers  (copy-tree supers)
  275.     canonical-slots   (copy-tree canonical-slots)
  276.     canonical-options (copy-tree canonical-options))
  277.   (do-standard-defsetfs-for-defclass accessor-names)
  278.   (let ((ecd
  279.       (make-early-class-definition name
  280.                        (load-truename)
  281.                        metaclass
  282.                        supers
  283.                        canonical-slots
  284.                        (apply #'append canonical-options)))
  285.     (existing
  286.       (find name *early-class-definitions* :key #'ecd-class-name)))
  287.     (setq *early-class-definitions*
  288.       (cons ecd (remove existing *early-class-definitions*)))
  289.     ecd))
  290.